home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / f2c-9510.000 / f2c-9510 / f2c-951007-libs-1.1 / src / misc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-10-07  |  21.3 KB  |  1,331 lines
  1. /****************************************************************
  2. Copyright 1990, 1992 - 1995 by AT&T Bell Laboratories and Bellcore.
  3.  
  4. Permission to use, copy, modify, and distribute this software
  5. and its documentation for any purpose and without fee is hereby
  6. granted, provided that the above copyright notice appear in all
  7. copies and that both that the copyright notice and this
  8. permission notice and warranty disclaimer appear in supporting
  9. documentation, and that the names of AT&T Bell Laboratories or
  10. Bellcore or any of their entities not be used in advertising or
  11. publicity pertaining to distribution of the software without
  12. specific, written prior permission.
  13.  
  14. AT&T and Bellcore disclaim all warranties with regard to this
  15. software, including all implied warranties of merchantability
  16. and fitness.  In no event shall AT&T or Bellcore be liable for
  17. any special, indirect or consequential damages or any damages
  18. whatsoever resulting from loss of use, data or profits, whether
  19. in an action of contract, negligence or other tortious action,
  20. arising out of or in connection with the use or performance of
  21. this software.
  22. ****************************************************************/
  23.  
  24. #include "defs.h"
  25. #include "limits.h"
  26.  
  27.  int
  28. #ifdef KR_headers
  29. oneof_stg(name, stg, mask)
  30.     Namep name;
  31.     int stg;
  32.     int mask;
  33. #else
  34. oneof_stg(Namep name, int stg, int mask)
  35. #endif
  36. {
  37.     if (stg == STGCOMMON && name) {
  38.         if ((mask & M(STGEQUIV)))
  39.             return name->vcommequiv;
  40.         if ((mask & M(STGCOMMON)))
  41.             return !name->vcommequiv;
  42.         }
  43.     return ONEOF(stg, mask);
  44.     }
  45.  
  46.  
  47. /* op_assign -- given a binary opcode, return the associated assignment
  48.    operator */
  49.  
  50.  int
  51. #ifdef KR_headers
  52. op_assign(opcode)
  53.     int opcode;
  54. #else
  55. op_assign(int opcode)
  56. #endif
  57. {
  58.     int retval = -1;
  59.  
  60.     switch (opcode) {
  61.         case OPPLUS: retval = OPPLUSEQ; break;
  62.     case OPMINUS: retval = OPMINUSEQ; break;
  63.     case OPSTAR: retval = OPSTAREQ; break;
  64.     case OPSLASH: retval = OPSLASHEQ; break;
  65.     case OPMOD: retval = OPMODEQ; break;
  66.     case OPLSHIFT: retval = OPLSHIFTEQ; break;
  67.     case OPRSHIFT: retval = OPRSHIFTEQ; break;
  68.     case OPBITAND: retval = OPBITANDEQ; break;
  69.     case OPBITXOR: retval = OPBITXOREQ; break;
  70.     case OPBITOR: retval = OPBITOREQ; break;
  71.     default:
  72.         erri ("op_assign:  bad opcode '%d'", opcode);
  73.         break;
  74.     } /* switch */
  75.  
  76.     return retval;
  77. } /* op_assign */
  78.  
  79.  
  80.  char *
  81. #ifdef KR_headers
  82. Alloc(n)
  83.     int n;
  84. #else
  85. Alloc(int n)
  86. #endif
  87.         /* error-checking version of malloc */
  88.         /* ckalloc initializes memory to 0; Alloc does not */
  89. {
  90.     char errbuf[32];
  91.     register char *rv;
  92.  
  93.     rv = malloc(n);
  94.     if (!rv) {
  95.         sprintf(errbuf, "malloc(%d) failure!", n);
  96.         Fatal(errbuf);
  97.         }
  98.     return rv;
  99.     }
  100.  
  101.  void
  102. #ifdef KR_headers
  103. cpn(n, a, b)
  104.     register int n;
  105.     register char *a;
  106.     register char *b;
  107. #else
  108. cpn(register int n, register char *a, register char *b)
  109. #endif
  110. {
  111.     while(--n >= 0)
  112.         *b++ = *a++;
  113. }
  114.  
  115.  
  116.  int
  117. #ifdef KR_headers
  118. eqn(n, a, b)
  119.     register int n;
  120.     register char *a;
  121.     register char *b;
  122. #else
  123. eqn(register int n, register char *a, register char *b)
  124. #endif
  125. {
  126.     while(--n >= 0)
  127.         if(*a++ != *b++)
  128.             return(NO);
  129.     return(YES);
  130. }
  131.  
  132.  
  133.  
  134.  
  135.  
  136.  
  137.  int
  138. #ifdef KR_headers
  139. cmpstr(a, b, la, lb)
  140.     register char *a;
  141.     register char *b;
  142.     ftnint la;
  143.     ftnint lb;
  144. #else
  145. cmpstr(register char *a, register char *b, ftnint la, ftnint lb)
  146. #endif
  147.     /* compare two strings */
  148. {
  149.     register char *aend, *bend;
  150.     aend = a + la;
  151.     bend = b + lb;
  152.  
  153.  
  154.     if(la <= lb)
  155.     {
  156.         while(a < aend)
  157.             if(*a != *b)
  158.                 return( *a - *b );
  159.             else
  160.             {
  161.                 ++a;
  162.                 ++b;
  163.             }
  164.  
  165.         while(b < bend)
  166.             if(*b != ' ')
  167.                 return(' ' - *b);
  168.             else
  169.                 ++b;
  170.     }
  171.  
  172.     else
  173.     {
  174.         while(b < bend)
  175.             if(*a != *b)
  176.                 return( *a - *b );
  177.             else
  178.             {
  179.                 ++a;
  180.                 ++b;
  181.             }
  182.         while(a < aend)
  183.             if(*a != ' ')
  184.                 return(*a - ' ');
  185.             else
  186.                 ++a;
  187.     }
  188.     return(0);
  189. }
  190.  
  191.  
  192. /* hookup -- Same as LISP NCONC, that is a destructive append of two lists */
  193.  
  194.  chainp
  195. #ifdef KR_headers
  196. hookup(x, y)
  197.     register chainp x;
  198.     register chainp y;
  199. #else
  200. hookup(register chainp x, register chainp y)
  201. #endif
  202. {
  203.     register chainp p;
  204.  
  205.     if(x == NULL)
  206.         return(y);
  207.  
  208.     for(p = x ; p->nextp ; p = p->nextp)
  209.         ;
  210.     p->nextp = y;
  211.     return(x);
  212. }
  213.  
  214.  
  215.  
  216.  struct Listblock *
  217. #ifdef KR_headers
  218. mklist(p)
  219.     chainp p;
  220. #else
  221. mklist(chainp p)
  222. #endif
  223. {
  224.     register struct Listblock *q;
  225.  
  226.     q = ALLOC(Listblock);
  227.     q->tag = TLIST;
  228.     q->listp = p;
  229.     return(q);
  230. }
  231.  
  232.  
  233.  chainp
  234. #ifdef KR_headers
  235. mkchain(p, q)
  236.     register char * p;
  237.     register chainp q;
  238. #else
  239. mkchain(register char * p, register chainp q)
  240. #endif
  241. {
  242.     register chainp r;
  243.  
  244.     if(chains)
  245.     {
  246.         r = chains;
  247.         chains = chains->nextp;
  248.     }
  249.     else
  250.         r = ALLOC(Chain);
  251.  
  252.     r->datap = p;
  253.     r->nextp = q;
  254.     return(r);
  255. }
  256.  
  257.  chainp
  258. #ifdef KR_headers
  259. revchain(next)
  260.     register chainp next;
  261. #else
  262. revchain(register chainp next)
  263. #endif
  264. {
  265.     register chainp p, prev = 0;
  266.  
  267.     while(p = next) {
  268.         next = p->nextp;
  269.         p->nextp = prev;
  270.         prev = p;
  271.         }
  272.     return prev;
  273.     }
  274.  
  275.  
  276. /* addunder -- turn a cvarname into an external name */
  277. /* The cvarname may already end in _ (to avoid C keywords); */
  278. /* if not, it has room for appending an _. */
  279.  
  280.  char *
  281. #ifdef KR_headers
  282. addunder(s)
  283.     register char *s;
  284. #else
  285. addunder(register char *s)
  286. #endif
  287. {
  288.     register int c, i, j;
  289.     char *s0 = s;
  290.  
  291.     i = j = 0;
  292.     while(c = *s++)
  293.         if (c == '_')
  294.             i++, j++;
  295.         else
  296.             i = 0;
  297.     if (!i) {
  298.         *s-- = 0;
  299.         *s = '_';
  300.         }
  301.     else if (j == 2)
  302.         s[-2] = 0;
  303.     return( s0 );
  304.     }
  305.  
  306.  
  307. /* copyn -- return a new copy of the input Fortran-string */
  308.  
  309.  char *
  310. #ifdef KR_headers
  311. copyn(n, s)
  312.     register int n;
  313.     register char *s;
  314. #else
  315. copyn(register int n, register char *s)
  316. #endif
  317. {
  318.     register char *p, *q;
  319.  
  320.     p = q = (char *) Alloc(n);
  321.     while(--n >= 0)
  322.         *q++ = *s++;
  323.     return(p);
  324. }
  325.  
  326.  
  327.  
  328. /* copys -- return a new copy of the input C-string */
  329.  
  330.  char *
  331. #ifdef KR_headers
  332. copys(s)
  333.     char *s;
  334. #else
  335. copys(char *s)
  336. #endif
  337. {
  338.     return( copyn( strlen(s)+1 , s) );
  339. }
  340.  
  341.  
  342.  
  343. /* convci -- Convert Fortran-string to integer; assumes that input is a
  344.    legal number, with no trailing blanks */
  345.  
  346.  ftnint
  347. #ifdef KR_headers
  348. convci(n, s)
  349.     register int n;
  350.     register char *s;
  351. #else
  352. convci(register int n, register char *s)
  353. #endif
  354. {
  355.     ftnint sum, t;
  356.     char buff[100], *s0;
  357.     int n0;
  358.  
  359.     s0 = s;
  360.     n0 = n;
  361.     sum = 0;
  362.     while(n-- > 0) {
  363.         /* sum = 10*sum + (*s++ - '0'); */
  364.         t = *s++ - '0';
  365.         if (sum > LONG_MAX/10) {
  366.  ovfl:
  367.             if (n0 > 60)
  368.                 n0 = 60;
  369.             sprintf(buff, "integer constant %.*s truncated.",
  370.                 n0, s0);
  371.             err(buff);
  372.             return LONG_MAX;
  373.             }
  374.         sum *= 10;
  375.         if (sum > LONG_MAX - t)
  376.             goto ovfl;
  377.         sum += t;
  378.         }
  379.     return(sum);
  380.     }
  381.  
  382. /* convic - Convert Integer constant to string */
  383.  
  384.  char *
  385. #ifdef KR_headers
  386. convic(n)
  387.     ftnint n;
  388. #else
  389. convic(ftnint n)
  390. #endif
  391. {
  392.     static char s[20];
  393.     register char *t;
  394.  
  395.     s[19] = '\0';
  396.     t = s+19;
  397.  
  398.     do    {
  399.         *--t = '0' + n%10;
  400.         n /= 10;
  401.     } while(n > 0);
  402.  
  403.     return(t);
  404. }
  405.  
  406.  
  407.  
  408. /* mkname -- add a new identifier to the environment, including the closed
  409.    hash table. */
  410.  
  411.  Namep
  412. #ifdef KR_headers
  413. mkname(s)
  414.     register char *s;
  415. #else
  416. mkname(register char *s)
  417. #endif
  418. {
  419.     struct Hashentry *hp;
  420.     register Namep q;
  421.     register int c, hash, i;
  422.     register char *t;
  423.     char *s0;
  424.     char errbuf[64];
  425.  
  426.     hash = i = 0;
  427.     s0 = s;
  428.     while(c = *s++) {
  429.         hash += c;
  430.         if (c == '_')
  431.             i = 2;
  432.         }
  433.     if (!i && in_vector(s0,c_keywords,n_keywords) >= 0)
  434.         i = 2;
  435.     hash %= maxhash;
  436.  
  437. /* Add the name to the closed hash table */
  438.  
  439.     hp = hashtab + hash;
  440.  
  441.     while(q = hp->varp)
  442.         if( hash == hp->hashval && !strcmp(s0,q->fvarname) )
  443.             return(q);
  444.         else if(++hp >= lasthash)
  445.             hp = hashtab;
  446.  
  447.     if(++nintnames >= maxhash-1)
  448.         many("names", 'n', maxhash);    /* Fatal error */
  449.     hp->varp = q = ALLOC(Nameblock);
  450.     hp->hashval = hash;
  451.     q->tag = TNAME;    /* TNAME means the tag type is NAME */
  452.     c = s - s0;
  453.     if (c > 7 && noextflag) {
  454.         sprintf(errbuf, "\"%.35s%s\" over 6 characters long", s0,
  455.             c > 36 ? "..." : "");
  456.         errext(errbuf);
  457.         }
  458.     q->fvarname = strcpy(mem(c,0), s0);
  459.     t = q->cvarname = mem(c + i + 1, 0);
  460.     s = s0;
  461.     /* add __ to the end of any name containing _ and to any C keyword */
  462.     while(*t = *s++)
  463.         t++;
  464.     if (i) {
  465.         do *t++ = '_';
  466.             while(--i > 0);
  467.         *t = 0;
  468.         }
  469.     return(q);
  470. }
  471.  
  472.  
  473.  struct Labelblock *
  474. #ifdef KR_headers
  475. mklabel(l)
  476.     ftnint l;
  477. #else
  478. mklabel(ftnint l)
  479. #endif
  480. {
  481.     register struct Labelblock *lp;
  482.  
  483.     if(l <= 0)
  484.         return(NULL);
  485.  
  486.     for(lp = labeltab ; lp < highlabtab ; ++lp)
  487.         if(lp->stateno == l)
  488.             return(lp);
  489.  
  490.     if(++highlabtab > labtabend)
  491.         many("statement labels", 's', maxstno);
  492.  
  493.     lp->stateno = l;
  494.     lp->labelno = newlabel();
  495.     lp->blklevel = 0;
  496.     lp->labused = NO;
  497.     lp->fmtlabused = NO;
  498.     lp->labdefined = NO;
  499.     lp->labinacc = NO;
  500.     lp->labtype = LABUNKNOWN;
  501.     lp->fmtstring = 0;
  502.     return(lp);
  503. }
  504.  
  505.  
  506.  int
  507. newlabel(Void)
  508. {
  509.     return( ++lastlabno );
  510. }
  511.  
  512.  
  513. /* this label appears in a branch context */
  514.  
  515.  struct Labelblock *
  516. #ifdef KR_headers
  517. execlab(stateno)
  518.     ftnint stateno;
  519. #else
  520. execlab(ftnint stateno)
  521. #endif
  522. {
  523.     register struct Labelblock *lp;
  524.  
  525.     if(lp = mklabel(stateno))
  526.     {
  527.         if(lp->labinacc)
  528.             warn1("illegal branch to inner block, statement label %s",
  529.                 convic(stateno) );
  530.         else if(lp->labdefined == NO)
  531.             lp->blklevel = blklevel;
  532.         if(lp->labtype == LABFORMAT)
  533.             err("may not branch to a format");
  534.         else
  535.             lp->labtype = LABEXEC;
  536.     }
  537.     else
  538.         execerr("illegal label %s", convic(stateno));
  539.  
  540.     return(lp);
  541. }
  542.  
  543.  
  544. /* find or put a name in the external symbol table */
  545.  
  546.  Extsym *
  547. #ifdef KR_headers
  548. mkext1(f, s)
  549.     char *f;
  550.     char *s;
  551. #else
  552. mkext1(char *f, char *s)
  553. #endif
  554. {
  555.     Extsym *p;
  556.  
  557.     for(p = extsymtab ; p<nextext ; ++p)
  558.         if(!strcmp(s,p->cextname))
  559.             return( p );
  560.  
  561.     if(nextext >= lastext)
  562.         many("external symbols", 'x', maxext);
  563.  
  564.     nextext->fextname = strcpy(gmem(strlen(f)+1,0), f);
  565.     nextext->cextname = f == s
  566.                 ? nextext->fextname
  567.                 : strcpy(gmem(strlen(s)+1,0), s);
  568.     nextext->extstg = STGUNKNOWN;
  569.     nextext->extp = 0;
  570.     nextext->allextp = 0;
  571.     nextext->extleng = 0;
  572.     nextext->maxleng = 0;
  573.     nextext->extinit = 0;
  574.     nextext->curno = nextext->maxno = 0;
  575.     return( nextext++ );
  576. }
  577.  
  578.  
  579.  Extsym *
  580. #ifdef KR_headers
  581. mkext(f, s)
  582.     char *f;
  583.     char *s;
  584. #else
  585. mkext(char *f, char *s)
  586. #endif
  587. {
  588.     Extsym *e = mkext1(f, s);
  589.     if (e->extstg == STGCOMMON)
  590.         errstr("%.52s cannot be a subprogram: it is a common block.",f);
  591.     return e;
  592.     }
  593.  
  594.  Addrp
  595. #ifdef KR_headers
  596. builtin(t, s, dbi)
  597.     int t;
  598.     char *s;
  599.     int dbi;
  600. #else
  601. builtin(int t, char *s, int dbi)
  602. #endif
  603. {
  604.     register Extsym *p;
  605.     register Addrp q;
  606.     extern chainp used_builtins;
  607.  
  608.     p = mkext(s,s);
  609.     if(p->extstg == STGUNKNOWN)
  610.         p->extstg = STGEXT;
  611.     else if(p->extstg != STGEXT)
  612.     {
  613.         errstr("improper use of builtin %s", s);
  614.         return(0);
  615.     }
  616.  
  617.     q = ALLOC(Addrblock);
  618.     q->tag = TADDR;
  619.     q->vtype = t;
  620.     q->vclass = CLPROC;
  621.     q->vstg = STGEXT;
  622.     q->memno = p - extsymtab;
  623.     q->dbl_builtin = dbi;
  624.  
  625. /* A NULL pointer here tells you to use   memno   to check the external
  626.    symbol table */
  627.  
  628.     q -> uname_tag = UNAM_EXTERN;
  629.  
  630. /* Add to the list of used builtins */
  631.  
  632.     if (dbi >= 0)
  633.         add_extern_to_list (q, &used_builtins);
  634.     return(q);
  635. }
  636.  
  637.  
  638.  void
  639. #ifdef KR_headers
  640. add_extern_to_list(addr, list_store)
  641.     Addrp addr;
  642.     chainp *list_store;
  643. #else
  644. add_extern_to_list(Addrp addr, chainp *list_store)
  645. #endif
  646. {
  647.     chainp last = CHNULL;
  648.     chainp list;
  649.     int memno;
  650.  
  651.     if (list_store == (chainp *) NULL || addr == (Addrp) NULL)
  652.     return;
  653.  
  654.     list = *list_store;
  655.     memno = addr -> memno;
  656.  
  657.     for (;list; last = list, list = list -> nextp) {
  658.     Addrp this = (Addrp) (list -> datap);
  659.  
  660.     if (this -> tag == TADDR && this -> uname_tag == UNAM_EXTERN &&
  661.         this -> memno == memno)
  662.         return;
  663.     } /* for */
  664.  
  665.     if (*list_store == CHNULL)
  666.     *list_store = mkchain((char *)cpexpr((expptr)addr), CHNULL);
  667.     else
  668.     last->nextp = mkchain((char *)cpexpr((expptr)addr), CHNULL);
  669.  
  670. } /* add_extern_to_list */
  671.  
  672.  
  673.  void
  674. #ifdef KR_headers
  675. frchain(p)
  676.     register chainp *p;
  677. #else
  678. frchain(register chainp *p)
  679. #endif
  680. {
  681.     register chainp q;
  682.  
  683.     if(p==0 || *p==0)
  684.         return;
  685.  
  686.     for(q = *p; q->nextp ; q = q->nextp)
  687.         ;
  688.     q->nextp = chains;
  689.     chains = *p;
  690.     *p = 0;
  691. }
  692.  
  693.  void
  694. #ifdef KR_headers
  695. frexchain(p)
  696.     register chainp *p;
  697. #else
  698. frexchain(register chainp *p)
  699. #endif
  700. {
  701.     register chainp q, r;
  702.  
  703.     if (q = *p) {
  704.         for(;;q = r) {
  705.             frexpr((expptr)q->datap);
  706.             if (!(r = q->nextp))
  707.                 break;
  708.             }
  709.         q->nextp = chains;
  710.         chains = *p;
  711.         *p = 0;
  712.         }
  713.     }
  714.  
  715.  
  716.  tagptr
  717. #ifdef KR_headers
  718. cpblock(n, p)
  719.     register int n;
  720.     register char *p;
  721. #else
  722. cpblock(register int n, register char *p)
  723. #endif
  724. {
  725.     register ptr q;
  726.  
  727.     memcpy((char *)(q = ckalloc(n)), (char *)p, n);
  728.     return( (tagptr) q);
  729. }
  730.  
  731.  
  732.  
  733.  ftnint
  734. #ifdef KR_headers
  735. lmax(a, b)
  736.     ftnint a;
  737.     ftnint b;
  738. #else
  739. lmax(ftnint a, ftnint b)
  740. #endif
  741. {
  742.     return( a>b ? a : b);
  743. }
  744.  
  745.  ftnint
  746. #ifdef KR_headers
  747. lmin(a, b)
  748.     ftnint a;
  749.     ftnint b;
  750. #else
  751. lmin(ftnint a, ftnint b)
  752. #endif
  753. {
  754.     return(a < b ? a : b);
  755. }
  756.  
  757.  
  758.  
  759.  
  760. #ifdef KR_headers
  761. maxtype(t1, t2)
  762.     int t1;
  763.     int t2;
  764. #else
  765. maxtype(int t1, int t2)
  766. #endif
  767. {
  768.     int t;
  769.  
  770.     t = t1 >= t2 ? t1 : t2;
  771.     if(t==TYCOMPLEX && (t1==TYDREAL || t2==TYDREAL) )
  772.         t = TYDCOMPLEX;
  773.     return(t);
  774. }
  775.  
  776.  
  777.  
  778. /* return log base 2 of n if n a power of 2; otherwise -1 */
  779.  int
  780. #ifdef KR_headers
  781. log_2(n)
  782.     ftnint n;
  783. #else
  784. log_2(ftnint n)
  785. #endif
  786. {
  787.     int k;
  788.  
  789.     /* trick based on binary representation */
  790.  
  791.     if(n<=0 || (n & (n-1))!=0)
  792.         return(-1);
  793.  
  794.     for(k = 0 ;  n >>= 1  ; ++k)
  795.         ;
  796.     return(k);
  797. }
  798.  
  799.  
  800.  void
  801. frrpl(Void)
  802. {
  803.     struct Rplblock *rp;
  804.  
  805.     while(rpllist)
  806.     {
  807.         rp = rpllist->rplnextp;
  808.         free( (charptr) rpllist);
  809.         rpllist = rp;
  810.     }
  811. }
  812.  
  813.  
  814.  
  815. /* Call a Fortran function with an arbitrary list of arguments */
  816.  
  817. int callk_kludge;
  818.  
  819.  expptr
  820. #ifdef KR_headers
  821. callk(type, name, args)
  822.     int type;
  823.     char *name;
  824.     chainp args;
  825. #else
  826. callk(int type, char *name, chainp args)
  827. #endif
  828. {
  829.     register expptr p;
  830.  
  831.     p = mkexpr(OPCALL,
  832.         (expptr)builtin(callk_kludge ? callk_kludge : type, name, 0),
  833.         (expptr)args);
  834.     p->exprblock.vtype = type;
  835.     return(p);
  836. }
  837.  
  838.  
  839.  
  840.  expptr
  841. #ifdef KR_headers
  842. call4(type, name, arg1, arg2, arg3, arg4)
  843.     int type;
  844.     char *name;
  845.     expptr arg1;
  846.     expptr arg2;
  847.     expptr arg3;
  848.     expptr arg4;
  849. #else
  850. call4(int type, char *name, expptr arg1, expptr arg2, expptr arg3, expptr arg4)
  851. #endif
  852. {
  853.     struct Listblock *args;
  854.     args = mklist( mkchain((char *)arg1,
  855.             mkchain((char *)arg2,
  856.                 mkchain((char *)arg3,
  857.                         mkchain((char *)arg4, CHNULL)) ) ) );
  858.     return( callk(type, name, (chainp)args) );
  859. }
  860.  
  861.  
  862.  
  863.  
  864.  expptr
  865. #ifdef KR_headers
  866. call3(type, name, arg1, arg2, arg3)
  867.     int type;
  868.     char *name;
  869.     expptr arg1;
  870.     expptr arg2;
  871.     expptr arg3;
  872. #else
  873. call3(int type, char *name, expptr arg1, expptr arg2, expptr arg3)
  874. #endif
  875. {
  876.     struct Listblock *args;
  877.     args = mklist( mkchain((char *)arg1,
  878.             mkchain((char *)arg2,
  879.                 mkchain((char *)arg3, CHNULL) ) ) );
  880.     return( callk(type, name, (chainp)args) );
  881. }
  882.  
  883.  
  884.  
  885.  
  886.  
  887.  expptr
  888. #ifdef KR_headers
  889. call2(type, name, arg1, arg2)
  890.     int type;
  891.     char *name;
  892.     expptr arg1;
  893.     expptr arg2;
  894. #else
  895. call2(int type, char *name, expptr arg1, expptr arg2)
  896. #endif
  897. {
  898.     struct Listblock *args;
  899.  
  900.     args = mklist( mkchain((char *)arg1, mkchain((char *)arg2, CHNULL) ) );
  901.     return( callk(type,name, (chainp)args) );
  902. }
  903.  
  904.  
  905.  
  906.  
  907.  expptr
  908. #ifdef KR_headers
  909. call1(type, name, arg)
  910.     int type;
  911.     char *name;
  912.     expptr arg;
  913. #else
  914. call1(int type, char *name, expptr arg)
  915. #endif
  916. {
  917.     return( callk(type,name, (chainp)mklist(mkchain((char *)arg,CHNULL)) ));
  918. }
  919.  
  920.  
  921.  expptr
  922. #ifdef KR_headers
  923. call0(type, name)
  924.     int type;
  925.     char *name;
  926. #else
  927. call0(int type, char *name)
  928. #endif
  929. {
  930.     return( callk(type, name, CHNULL) );
  931. }
  932.  
  933.  
  934.  
  935.  struct Impldoblock *
  936. #ifdef KR_headers
  937. mkiodo(dospec, list)
  938.     chainp dospec;
  939.     chainp list;
  940. #else
  941. mkiodo(chainp dospec, chainp list)
  942. #endif
  943. {
  944.     register struct Impldoblock *q;
  945.  
  946.     q = ALLOC(Impldoblock);
  947.     q->tag = TIMPLDO;
  948.     q->impdospec = dospec;
  949.     q->datalist = list;
  950.     return(q);
  951. }
  952.  
  953.  
  954.  
  955.  
  956. /* ckalloc -- Allocate 1 memory unit of size   n,   checking for out of
  957.    memory error */
  958.  
  959.  ptr
  960. #ifdef KR_headers
  961. ckalloc(n)
  962.     register int n;
  963. #else
  964. ckalloc(register int n)
  965. #endif
  966. {
  967.     register ptr p;
  968.     p = (ptr)calloc(1, (unsigned) n);
  969.     if (p || !n)
  970.         return(p);
  971.     fprintf(stderr, "failing to get %d bytes\n",n);
  972.     Fatal("out of memory");
  973.     /* NOT REACHED */ return 0;
  974. }
  975.  
  976.  
  977.  int
  978. #ifdef KR_headers
  979. isaddr(p)
  980.     register expptr p;
  981. #else
  982. isaddr(register expptr p)
  983. #endif
  984. {
  985.     if(p->tag == TADDR)
  986.         return(YES);
  987.     if(p->tag == TEXPR)
  988.         switch(p->exprblock.opcode)
  989.         {
  990.         case OPCOMMA:
  991.             return( isaddr(p->exprblock.rightp) );
  992.  
  993.         case OPASSIGN:
  994.         case OPASSIGNI:
  995.         case OPPLUSEQ:
  996.         case OPMINUSEQ:
  997.         case OPSLASHEQ:
  998.         case OPMODEQ:
  999.         case OPLSHIFTEQ:
  1000.         case OPRSHIFTEQ:
  1001.         case OPBITANDEQ:
  1002.         case OPBITXOREQ:
  1003.         case OPBITOREQ:
  1004.             return( isaddr(p->exprblock.leftp) );
  1005.         }
  1006.     return(NO);
  1007. }
  1008.  
  1009.  
  1010.  
  1011.  int
  1012. #ifdef KR_headers
  1013. isstatic(p)
  1014.     register expptr p;
  1015. #else
  1016. isstatic(register expptr p)
  1017. #endif
  1018. {
  1019.     extern int useauto;
  1020.     if(p->headblock.vleng && !ISCONST(p->headblock.vleng))
  1021.         return(NO);
  1022.  
  1023.     switch(p->tag)
  1024.     {
  1025.     case TCONST:
  1026.         return(YES);
  1027.  
  1028.     case TADDR:
  1029.         if(ONEOF(p->addrblock.vstg,MSKSTATIC) &&
  1030.             ISCONST(p->addrblock.memoffset) && !useauto)
  1031.             return(YES);
  1032.  
  1033.     default:
  1034.         return(NO);
  1035.     }
  1036. }
  1037.  
  1038.  
  1039.  
  1040. /* addressable -- return True iff it is a constant value, or can be
  1041.    referenced by constant values */
  1042.  
  1043.  int
  1044. #ifdef KR_headers
  1045. addressable(p)
  1046.     register expptr p;
  1047. #else
  1048. addressable(register expptr p)
  1049. #endif
  1050. {
  1051.     switch(p->tag)
  1052.     {
  1053.     case TCONST:
  1054.         return(YES);
  1055.  
  1056.     case TADDR:
  1057.         return( addressable(p->addrblock.memoffset) );
  1058.  
  1059.     default:
  1060.         return(NO);
  1061.     }
  1062. }
  1063.  
  1064.  
  1065. /* isnegative_const -- returns true if the constant is negative.  Returns
  1066.    false for imaginary and nonnumeric constants */
  1067.  
  1068.  int
  1069. #ifdef KR_headers
  1070. isnegative_const(cp)
  1071.     struct Constblock *cp;
  1072. #else
  1073. isnegative_const(struct Constblock *cp)
  1074. #endif
  1075. {
  1076.     int retval;
  1077.  
  1078.     if (cp == NULL)
  1079.     return 0;
  1080.  
  1081.     switch (cp -> vtype) {
  1082.     case TYINT1:
  1083.         case TYSHORT:
  1084.     case TYLONG:
  1085. #ifdef TYQUAD
  1086.     case TYQUAD:
  1087. #endif
  1088.         retval = cp -> Const.ci < 0;
  1089.         break;
  1090.     case TYREAL:
  1091.     case TYDREAL:
  1092.         retval = cp->vstg ? *cp->Const.cds[0] == '-'
  1093.                   :  cp->Const.cd[0] < 0.0;
  1094.         break;
  1095.     default:
  1096.  
  1097.         retval = 0;
  1098.         break;
  1099.     } /* switch */
  1100.  
  1101.     return retval;
  1102. } /* isnegative_const */
  1103.  
  1104.  void
  1105. #ifdef KR_headers
  1106. negate_const(cp)
  1107.     Constp cp;
  1108. #else
  1109. negate_const(Constp cp)
  1110. #endif
  1111. {
  1112.     if (cp == (struct Constblock *) NULL)
  1113.     return;
  1114.  
  1115.     switch (cp -> vtype) {
  1116.     case TYINT1:
  1117.     case TYSHORT:
  1118.     case TYLONG:
  1119. #ifdef TYQUAD
  1120.     case TYQUAD:
  1121. #endif
  1122.         cp -> Const.ci = - cp -> Const.ci;
  1123.         break;
  1124.     case TYCOMPLEX:
  1125.     case TYDCOMPLEX:
  1126.         if (cp->vstg)
  1127.             switch(*cp->Const.cds[1]) {
  1128.             case '-':
  1129.                 ++cp->Const.cds[1];
  1130.                 break;
  1131.             case '0':
  1132.                 break;
  1133.             default:
  1134.                 --cp->Const.cds[1];
  1135.             }
  1136.         else
  1137.                 cp->Const.cd[1] = -cp->Const.cd[1];
  1138.         /* no break */
  1139.     case TYREAL:
  1140.     case TYDREAL:
  1141.         if (cp->vstg)
  1142.             switch(*cp->Const.cds[0]) {
  1143.             case '-':
  1144.                 ++cp->Const.cds[0];
  1145.                 break;
  1146.             case '0':
  1147.                 break;
  1148.             default:
  1149.                 --cp->Const.cds[0];
  1150.             }
  1151.         else
  1152.                 cp->Const.cd[0] = -cp->Const.cd[0];
  1153.         break;
  1154.     case TYCHAR:
  1155.     case TYLOGICAL1:
  1156.     case TYLOGICAL2:
  1157.     case TYLOGICAL:
  1158.         erri ("negate_const:  can't negate type '%d'", cp -> vtype);
  1159.         break;
  1160.     default:
  1161.         erri ("negate_const:  bad type '%d'",
  1162.             cp -> vtype);
  1163.         break;
  1164.     } /* switch */
  1165. } /* negate_const */
  1166.  
  1167.  void
  1168. #ifdef KR_headers
  1169. ffilecopy(infp, outfp)
  1170.     FILE *infp;
  1171.     FILE *outfp;
  1172. #else
  1173. ffilecopy(FILE *infp, FILE *outfp)
  1174. #endif
  1175. {
  1176.     while (!feof (infp)) {
  1177.     register c = getc (infp);
  1178.     if (!feof (infp))
  1179.     putc (c, outfp);
  1180.     } /* while */
  1181. } /* ffilecopy */
  1182.  
  1183.  
  1184. /* in_vector -- verifies whether   str   is in c_keywords.
  1185.    If so, the index is returned else  -1  is returned.
  1186.    c_keywords must be in alphabetical order (as defined by strcmp).
  1187. */
  1188.  
  1189.  int
  1190. #ifdef KR_headers
  1191. in_vector(str, keywds, n)
  1192.     char *str;
  1193.     char **keywds;
  1194.     register int n;
  1195. #else
  1196. in_vector(char *str, char **keywds, register int n)
  1197. #endif
  1198. {
  1199.     register char **K = keywds;
  1200.     register int n1, t;
  1201.  
  1202.     do {
  1203.         n1 = n >> 1;
  1204.         if (!(t = strcmp(str, K[n1])))
  1205.             return K - keywds + n1;
  1206.         if (t < 0)
  1207.             n = n1;
  1208.         else {
  1209.             n -= ++n1;
  1210.             K += n1;
  1211.             }
  1212.         }
  1213.         while(n > 0);
  1214.  
  1215.     return -1;
  1216.     } /* in_vector */
  1217.  
  1218.  
  1219.  int
  1220. #ifdef KR_headers
  1221. is_negatable(Const)
  1222.     Constp Const;
  1223. #else
  1224. is_negatable(Constp Const)
  1225. #endif
  1226. {
  1227.     int retval = 0;
  1228.     if (Const != (Constp) NULL)
  1229.     switch (Const -> vtype) {
  1230.         case TYINT1:
  1231.         retval = Const -> Const.ci >= -BIGGEST_CHAR;
  1232.         break;
  1233.         case TYSHORT:
  1234.             retval = Const -> Const.ci >= -BIGGEST_SHORT;
  1235.             break;
  1236.         case TYLONG:
  1237. #ifdef TYQUAD
  1238.         case TYQUAD:
  1239. #endif
  1240.             retval = Const -> Const.ci >= -BIGGEST_LONG;
  1241.             break;
  1242.         case TYREAL:
  1243.         case TYDREAL:
  1244.         case TYCOMPLEX:
  1245.         case TYDCOMPLEX:
  1246.             retval = 1;
  1247.             break;
  1248.         case TYLOGICAL1:
  1249.         case TYLOGICAL2:
  1250.         case TYLOGICAL:
  1251.         case TYCHAR:
  1252.         case TYSUBR:
  1253.         default:
  1254.             retval = 0;
  1255.             break;
  1256.     } /* switch */
  1257.  
  1258.     return retval;
  1259. } /* is_negatable */
  1260.  
  1261.  void
  1262. #ifdef KR_headers
  1263. backup(fname, bname)
  1264.     char *fname;
  1265.     char *bname;
  1266. #else
  1267. backup(char *fname, char *bname)
  1268. #endif
  1269. {
  1270.     FILE *b, *f;
  1271.     static char couldnt[] = "Couldn't open %.80s";
  1272.  
  1273.     if (!(f = fopen(fname, binread))) {
  1274.         warn1(couldnt, fname);
  1275.         return;
  1276.         }
  1277.     if (!(b = fopen(bname, binwrite))) {
  1278.         warn1(couldnt, bname);
  1279.         return;
  1280.         }
  1281.     ffilecopy(f, b);
  1282.     fclose(f);
  1283.     fclose(b);
  1284.     }
  1285.  
  1286.  
  1287. /* struct_eq -- returns YES if structures have the same field names and
  1288.    types, NO otherwise */
  1289.  
  1290.  int
  1291. #ifdef KR_headers
  1292. struct_eq(s1, s2)
  1293.     chainp s1;
  1294.     chainp s2;
  1295. #else
  1296. struct_eq(chainp s1, chainp s2)
  1297. #endif
  1298. {
  1299.     struct Dimblock *d1, *d2;
  1300.     Constp cp1, cp2;
  1301.  
  1302.     if (s1 == CHNULL && s2 == CHNULL)
  1303.     return YES;
  1304.     for(; s1 && s2; s1 = s1->nextp, s2 = s2->nextp) {
  1305.     register Namep v1 = (Namep) s1 -> datap;
  1306.     register Namep v2 = (Namep) s2 -> datap;
  1307.  
  1308.     if (v1 == (Namep) NULL || v1 -> tag != TNAME ||
  1309.         v2 == (Namep) NULL || v2 -> tag != TNAME)
  1310.         return NO;
  1311.  
  1312.     if (v1->vtype != v2->vtype || v1->vclass != v2->vclass
  1313.         || strcmp(v1->fvarname, v2->fvarname))
  1314.         return NO;
  1315.  
  1316.     /* compare dimensions (needed for comparing COMMON blocks) */
  1317.  
  1318.     if (d1 = v1->vdim) {
  1319.         if (!(cp1 = (Constp)d1->nelt) || cp1->tag != TCONST
  1320.         ||  !(d2 = v2->vdim)
  1321.         ||  !(cp2 = (Constp)d2->nelt) || cp2->tag != TCONST
  1322.         ||  cp1->Const.ci != cp2->Const.ci)
  1323.             return NO;
  1324.         }
  1325.     else if (v2->vdim)
  1326.         return NO;
  1327.     } /* while s1 != CHNULL && s2 != CHNULL */
  1328.  
  1329.     return s1 == CHNULL && s2 == CHNULL;
  1330. } /* struct_eq */
  1331.